strings (including text properties), and pad with spaces so that
all are a uniform length. Replacements are performed using the
key and description replacement alists."
- (let ((max-key-width 0)) ;(max-desc-width 0)
+ (let ((max-key-width 0)
- (max-desc-width 0)
- (sep-w-face (propertize which-key-separator 'face 'which-key-separator-face))
- (sep-width (length which-key-separator))
- after-replacements)
++ (sep-w-face (propertize which-key-separator 'face 'which-key-separator-face))) ;(max-desc-width 0)
;; first replace and apply faces
- (setq after-replacements
- (mapcar
- (lambda (key-desc-cons)
- (let* ((key (car key-desc-cons))
- (desc (cdr key-desc-cons))
- (keys (concat prefix-keys " " key))
- (key (which-key/maybe-replace key which-key-key-replacement-alist))
- (desc (which-key/maybe-replace desc which-key-description-replacement-alist))
- (desc (which-key/maybe-replace-key-based desc keys))
- (group (string-match-p "^group:" desc))
- (desc (if group (substring desc 6) desc))
- (prefix (string-match-p "^Prefix" desc))
- (desc (if (or prefix group) (concat "+" desc) desc))
- (desc-face (if (or prefix group)
- 'which-key-group-description-face
- 'which-key-command-description-face))
- (desc (which-key/truncate-description desc))
- (key-w-face (which-key/propertize-key key))
- (desc-w-face (propertize desc 'face desc-face))
- (key-width (length (substring-no-properties key-w-face)))
- (desc-width (length (substring-no-properties desc-w-face))))
- (setq max-key-width (max key-width max-key-width))
- (setq max-desc-width (max desc-width max-desc-width))
- (cons key-w-face desc-w-face)))
- unformatted))
- ;; pad to max key-width and max desc-width
- (cons
- (mapcar (lambda (x)
- (concat (s-pad-left max-key-width " " (car x))
- " " sep-w-face " "
- (s-pad-right max-desc-width " " (cdr x))
- " "))
- after-replacements)
- (+ 3 max-key-width sep-width max-desc-width ))))
+ (mapcar
+ (lambda (key-desc-cons)
+ (let* ((key (car key-desc-cons))
+ (desc (cdr key-desc-cons))
+ (keys (concat prefix-keys " " key))
+ (key (which-key/maybe-replace
+ key which-key-key-replacement-alist))
+ (desc (which-key/maybe-replace
+ desc which-key-description-replacement-alist))
+ (desc (which-key/maybe-replace-key-based desc keys))
+ (group (string-match-p "^group:" desc))
+ (desc (if group (substring desc 6) desc))
+ (prefix (string-match-p "^Prefix" desc))
+ (desc (if (or prefix group) (concat "+" desc) desc))
+ (desc-face (if (or prefix group)
+ 'which-key-group-description-face
+ 'which-key-command-description-face))
+ (desc (which-key/truncate-description desc))
+ (key-w-face (which-key/propertize-key key))
+ (desc-w-face (propertize desc 'face desc-face))
+ (key-width (length (substring-no-properties key-w-face))))
+ ;; (desc-width (length (substring-no-properties desc-w-face))))
+ (setq max-key-width (max key-width max-key-width))
+ ;; (setq max-desc-width (max desc-width max-desc-width))
- (cons key-w-face desc-w-face)))
++ (list key-w-face sep-w-face desc-w-face)))
+ unformatted)))
+ ;; pad to max key-width and max desc-width
+
+ (defun which-key/get-formatted-key-bindings (buffer key)
+ (let ((key-str-qt (regexp-quote (key-description key)))
+ key-match desc-match unformatted format-res
+ formatted column-width)
+ (with-temp-buffer
+ (describe-buffer-bindings buffer key)
+ (goto-char (point-max)) ; want to put last keys in first
+ (while (re-search-backward
+ (format "^%s \\([^ \t]+\\)[ \t]+\\(\\(?:[^ \t\n]+ ?\\)+\\)$"
+ key-str-qt)
+ nil t)
+ (setq key-match (match-string 1)
+ desc-match (match-string 2))
+ (cl-pushnew (cons key-match desc-match) unformatted
+ :test (lambda (x y) (string-equal (car x) (car y))))))
+ (which-key/format-and-replace unformatted (key-description key))))
+
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;; Functions for laying out which-key buffer pages
+
-(defun which-key/create-page-vertical (max-lines max-width prefix-width key-cns)
++(defsubst which-key//max-len (keys index)
++ (cl-reduce
++ (lambda (x y) (max x (if (eq (car y) 'status)
++ 0 (length (substring-no-properties (nth index y))))))
++ keys :initial-value 0))
++
++(defun which-key/create-page-vertical (keys max-lines max-width prefix-width)
+ "Format KEYS into string representing a single page of text.
+ N-COLUMNS is the number of text columns to use and MAX-LINES is
+ the maximum number of lines availabel in the target buffer."
- (let* ((n-keys (length key-cns))
++ (let* ((n-keys (length keys))
+ (avl-lines max-lines)
+ (avl-width (- (+ 1 max-width) prefix-width)); we get 1 back for not putting a space after the last column
- (rem-key-cns key-cns)
++ (rem-keys keys)
+ (n-col-lines (min avl-lines n-keys))
+ (act-n-lines n-col-lines) ; n-col-lines in first column
+ (all-columns (list
+ (mapcar (lambda (i)
+ (if (> i 1) (s-repeat prefix-width " ") ""))
+ (number-sequence 1 n-col-lines))))
+ (act-width prefix-width)
- (sep-w-face (propertize which-key-separator
- 'face 'which-key-separator-face))
- col-key-cns col-key-width col-desc-width col-width col-split done
- n-columns new-column page)
++ col-keys col-key-width col-desc-width col-width col-split done
++ n-columns new-column page col-sep-width prev-rem-keys)
+ (while (not done)
- (setq col-split (-split-at n-col-lines rem-key-cns)
- col-key-cns (car col-split)
- rem-key-cns (cadr col-split)
- n-col-lines (min avl-lines (length rem-key-cns))
- col-key-width (cl-reduce (lambda (x y)
- (max x (length (substring-no-properties (car y)))))
- col-key-cns :initial-value 0)
- col-desc-width (cl-reduce (lambda (x y)
- (max x (length (substring-no-properties (cdr y)))))
- col-key-cns :initial-value 0)
- col-width (+ 3 (length (substring-no-properties sep-w-face))
- col-key-width col-desc-width)
++ (setq col-split (-split-at n-col-lines rem-keys)
++ col-keys (car col-split)
++ prev-rem-keys rem-keys
++ rem-keys (cadr col-split)
++ n-col-lines (min avl-lines (length col-keys))
++ col-key-width (which-key//max-len col-keys 0)
++ col-sep-width (which-key//max-len col-keys 1)
++ col-desc-width (which-key//max-len col-keys 2)
++ col-width (+ 3 col-key-width col-sep-width col-desc-width)
+ new-column (mapcar
+ (lambda (k)
- (concat (s-repeat (- col-key-width (length (substring-no-properties (car k)))) " ")
- (car k) " " sep-w-face " " (cdr k)
- (s-repeat (- col-desc-width (length (substring-no-properties (cdr k)))) " ")))
- col-key-cns))
++ (if (eq (car k) 'status)
++ (concat (s-repeat (+ col-key-width col-sep-width) " ") " " (cdr k))
++ (concat (s-repeat (- col-key-width
++ (length (substring-no-properties (nth 0 k)))) " ")
++ (nth 0 k) " " (nth 1 k) " " (nth 2 k)
++ (s-repeat (- col-desc-width
++ (length (substring-no-properties (nth 2 k)))) " "))))
++ col-keys))
+ (if (<= col-width avl-width)
+ (setq all-columns (push new-column all-columns)
+ act-width (+ act-width col-width)
- avl-width (- avl-width col-width))
- (setq done t))
- (when (<= (length rem-key-cns) 0) (setq done t)))
++ avl-width (- avl-width col-width))
++ (setq done t
++ rem-keys prev-rem-keys))
++ (when (<= (length rem-keys) 0) (setq done t)))
+ (setq all-columns (reverse all-columns)
+ n-columns (length all-columns))
+ (dotimes (i act-n-lines)
+ (dotimes (j n-columns)
+ (setq page (concat page (nth i (nth j all-columns))
+ (if (not (= j (- n-columns 1))) " "
+ (when (not (= i (- act-n-lines 1))) "\n"))))))
- (list page act-n-lines act-width rem-key-cns (- (length key-cns) (length rem-key-cns)))))
++ (list page act-n-lines act-width rem-keys (- n-keys (length rem-keys)))))
+
-(defun which-key/create-page (vertical max-lines max-width prefix-width key-cns)
- (let* ((first-try (which-key/create-page-vertical max-lines max-width prefix-width key-cns))
++(defun which-key/create-page (keys max-lines max-width prefix-width vertical use-status-key page-n)
++ (let* ((n-keys (length keys))
++ (first-try (which-key/create-page-vertical keys max-lines max-width prefix-width))
+ (n-rem-keys (length (nth 3 first-try)))
++ (status-key-i (- n-keys n-rem-keys 1))
+ (next-try-lines max-lines)
- prev-try prev-n-rem-keys next-try found)
- (if (or vertical (> n-rem-keys 0) (= max-lines 1))
- first-try
- ;; do a simple search for now (TODO: Implement binary search)
- (while (not found)
- (setq prev-try next-try
- next-try-lines (- next-try-lines 1)
- next-try (which-key/create-page-vertical next-try-lines max-width prefix-width key-cns)
- n-rem-keys (length (nth 3 next-try))
- found (or (= next-try-lines 0) (> n-rem-keys 0))))
- prev-try)))
++ prev-try prev-n-rem-keys next-try found status-key)
++ (cond ((and (> n-rem-keys 0) use-status-key)
++ (setq status-key
++ (cons 'status (propertize
++ (format "Page %s (%s not shown)" page-n (1+ n-rem-keys))
++ 'face 'font-lock-comment-face)))
++ (which-key/create-page-vertical (-insert-at status-key-i status-key keys)
++ max-lines max-width prefix-width))
++ ((or (> n-rem-keys 0) (= 1 max-lines)) first-try)
++ ;; do a simple search for now (TODO: Implement binary search)
++ (t (while (not found)
++ (setq prev-try next-try
++ next-try-lines (- next-try-lines 1)
++ next-try (which-key/create-page-vertical
++ keys next-try-lines max-width prefix-width)
++ n-rem-keys (length (nth 3 next-try))
++ found (or (= next-try-lines 0) (> n-rem-keys 0))))
++ prev-try))))
+
+ (defun which-key/populate-buffer (prefix-keys formatted-keys sel-win-width)
+ "Insert FORMATTED-STRINGS into which-key buffer, breaking after BUFFER-WIDTH."
+ (let* ((vertical (and (eq which-key-popup-type 'side-window)
+ (member which-key-side-window-location '(left right))))
++ (use-status-key t)
+ (prefix-w-face (which-key/propertize-key prefix-keys))
+ (prefix-len (+ 2 (length (substring-no-properties prefix-w-face))))
+ (prefix-string (when which-key-show-prefix
+ (if (eq which-key-show-prefix 'left)
+ (concat prefix-w-face " ")
+ (concat prefix-w-face "-\n"))))
- (n-keys (length formatted-keys))
+ (max-dims (which-key/popup-max-dimensions sel-win-width))
- (max-height (when (car max-dims) (car max-dims)))
++ (max-lines (when (car max-dims) (car max-dims)))
+ (prefix-width (if (eq which-key-show-prefix 'left) prefix-len 0))
+ (avl-width (when (cdr max-dims) (- (cdr max-dims) prefix-width)))
+ (keys-rem formatted-keys)
++ (page-n 0)
+ keys-per-page pages first-page first-page-str page-res)
+ (while keys-rem
- (setq page-res (which-key/create-page vertical max-height avl-width prefix-width keys-rem)
++ (setq page-n (1+ page-n)
++ page-res (which-key/create-page keys-rem
++ max-lines avl-width prefix-width
++ vertical use-status-key page-n)
+ pages (push page-res pages)
+ keys-per-page (push (if (nth 4 page-res) (nth 4 page-res) 0) keys-per-page)
+ keys-rem (nth 3 page-res)))
+ ;; not doing anything with other pages for now
+ (setq keys-per-page (reverse keys-per-page)
+ pages (reverse pages)
+ first-page (car pages)
+ first-page-str (concat prefix-string (car first-page)))
- (if (or (<= n-keys 0) (<= (car keys-per-page) 0))
++ (if (or (= (length formatted-keys) 0) (<= (car keys-per-page) 0))
+ (progn
+ (message "which-key can't show keys: The settings and/or frame size are too restrictive.")
+ (cons 0 0))
+ ;; (when (> (length pages) 1) (setq first-page (concat first-page "...")))
+ (if (eq which-key-popup-type 'minibuffer)
+ (let (message-log-max) (message "%s" first-page-str))
+ (with-current-buffer which-key--buffer
+ (erase-buffer)
+ (insert first-page-str)
+ (goto-char (point-min))))
+ (cons (nth 1 first-page) (nth 2 first-page)))))
+
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;; Update
+
+ (defun which-key/update ()
+ "Fill which-key--buffer with key descriptions and reformat.
+ Finally, show the buffer."
+ (let ((prefix-keys (this-single-command-keys)))
+ ;; (when (> (length prefix-keys) 0)
+ ;; (message "key: %s" (key-description prefix-keys)))
+ ;; (when (> (length prefix-keys) 0)
+ ;; (message "key binding: %s" (key-binding prefix-keys)))
+ (when (and (> (length prefix-keys) 0)
+ (keymapp (key-binding prefix-keys)))
+ (let* ((buf (current-buffer))
+ ;; get formatted key bindings
+ (formatted-keys (which-key/get-formatted-key-bindings
+ buf prefix-keys))
+ ;; populate target buffer
+ (popup-act-dim (which-key/populate-buffer
+ (key-description prefix-keys)
+ formatted-keys (window-width))))
+ ;; show buffer
+ (which-key/show-popup popup-act-dim)))))
+
+ ;; Timers
+ (defun which-key/start-open-timer ()
+ "Activate idle timer."
+ (which-key/stop-open-timer) ; start over
+ (setq which-key--open-timer
+ (run-with-idle-timer which-key-idle-delay t 'which-key/update)))
+
+ (defun which-key/stop-open-timer ()
+ "Deactivate idle timer."
+ (when which-key--open-timer (cancel-timer which-key--open-timer)))
(provide 'which-key)
;;; which-key.el ends here
projects / emacs.git / commitdiff